home *** CD-ROM | disk | FTP | other *** search
/ The Programmer Disk / The Programmer Disk (Microforum).iso / xpro / qb2 / pro1 / 3ddemo.bas next >
Encoding:
BASIC Source File  |  1992-08-23  |  5.2 KB  |  181 lines
  1. '
  2. ' 3dDemo.BAS by Brent Ashley - free for anyone's use.
  3. '
  4. DECLARE SUB Strip3D (t%, l%, b%, r%, StripType%)
  5. DECLARE SUB Fill (t%, l%, b%, r%, Fore%, Back%, Char$)
  6. DECLARE SUB DrawBox (t%, l%, b%, r%, TLFore%, TLBack%, BRFore%, BRBack%, BoxDef$)
  7. DECLARE SUB Box3D (t%, l%, b%, r%, BoxType%)
  8. DEFINT A-Z
  9.  
  10. DIM SHARED BaseClr, HiClr, ShadClr, ContClr
  11.  
  12. DEF SEG = 0
  13.  
  14. IF (PEEK(&H449) = 7) THEN Colour = 0 ELSE Colour = -1
  15.  
  16. ' uncomment this fo force black and white on a colour system:
  17. ' Colour = 0
  18.  
  19. IF Colour THEN
  20.   BaseClr = 3
  21.   HiClr = 15
  22.   ShadClr = 8
  23.   ContClr = 0
  24. ELSE
  25.   BaseClr = 7
  26.   HiClr = 15
  27.   ShadClr = 8
  28.   ContClr = 0
  29. END IF
  30. Mark$ = "■"
  31.  
  32.  
  33. ' first screen
  34. COLOR ContClr, BaseClr: CLS
  35. Box3D 2, 3, 21, 79, 0
  36. Box3D 5, 5, 9, 30, 1
  37. COLOR ContClr, BaseClr: LOCATE 7, 13: PRINT "Raised Box";
  38. Box3D 5, 51, 9, 76, 2
  39. COLOR ContClr, BaseClr: LOCATE 7, 58: PRINT "Recessed Box";
  40. Box3D 15, 5, 19, 30, 3
  41. COLOR ContClr, BaseClr: LOCATE 17, 12: PRINT "Raised Panel";
  42. Box3D 15, 51, 19, 76, 4
  43. COLOR ContClr, BaseClr: LOCATE 17, 57: PRINT "Recessed Panel";
  44. Strip3D 11, 25, 13, 55, 3
  45. COLOR BaseClr, ContClr: LOCATE 12, 32: PRINT "Raised Black Strip"
  46. Strip3D 23, 26, 23, 55, 4
  47. COLOR HiClr, ContClr: LOCATE 23, 27: PRINT " Press a key to continue... ";
  48. SLEEP: DO: LOOP WHILE LEN(INKEY$)
  49.  
  50. ' second screen
  51. COLOR BaseClr, ContClr: CLS
  52. Strip3D 3, 23, 3, 61, 1
  53. COLOR ContClr, BaseClr: LOCATE 3, 27: PRINT "Dialog Boxes can look like this!";
  54. Box3D 5, 5, 20, 75, 3
  55. COLOR ContClr, BaseClr: LOCATE 8, 8: PRINT "Data Entry:";
  56. Box3D 7, 20, 9, 73, 2
  57. Fill 8, 21, 8, 72, 7, 0, " "
  58. COLOR HiClr, ContClr: LOCATE 8, 22: PRINT "C:\DOS\FILENAME.EXT";
  59.  
  60. Box3D 11, 9, 19, 40, 1
  61. Strip3D 12, 12, 18, 14, 1
  62. COLOR ContClr, BaseClr
  63. LOCATE 12, 13: PRINT Mark$;
  64. LOCATE 12, 16: PRINT "This option"
  65. LOCATE 13, 13: PRINT Mark$;
  66. LOCATE 12, 16: PRINT "That option"
  67. LOCATE 13, 16: PRINT "The other option"
  68. LOCATE 14, 16: PRINT "Some further option"
  69. LOCATE 15, 13: PRINT Mark$;
  70. LOCATE 15, 16: PRINT "His option"
  71. LOCATE 16, 16: PRINT "Her option"
  72. LOCATE 17, 16: PRINT "Their option"
  73. LOCATE 18, 13: PRINT Mark$;
  74. LOCATE 18, 16: PRINT "Your option"
  75.  
  76. COLOR HiClr, BaseClr
  77. LOCATE 10, 50: PRINT " Characters "
  78. Strip3D 11, 45, 14, 70, 3
  79. COLOR BaseClr, ContClr
  80. LOCATE 11, 46: FOR i = 1 TO 24: PRINT CHR$(159 + i); : NEXT
  81. LOCATE 12, 46: FOR i = 1 TO 24: PRINT CHR$(183 + i); : NEXT
  82. LOCATE 13, 46: FOR i = 1 TO 24: PRINT CHR$(207 + i); : NEXT
  83. LOCATE 14, 46: FOR i = 1 TO 24: PRINT CHR$(231 + i); : NEXT
  84.  
  85. Box3D 16, 48, 19, 66, 4
  86. Strip3D 17, 59, 18, 62, 3
  87. COLOR HiClr, ContClr
  88. LOCATE 17, 60: PRINT "31";
  89. LOCATE 18, 60: PRINT " 6";
  90. COLOR ContClr, BaseClr
  91. LOCATE 17, 52: PRINT "Row"
  92. LOCATE 18, 52: PRINT "Column"
  93.  
  94. COLOR HiClr, ContClr: LOCATE 24, 27: PRINT " And thus ends the demo. ";
  95.  
  96. SUB Box3D (t, l, b, r, BoxType)
  97.   SELECT CASE BoxType
  98.     CASE 1 ' Raised
  99.       BoxDef$ = "╔═╕│┘─╙║ "
  100.       TLFore = HiClr: BRFore = ContClr
  101.       TLBack = BaseClr: BRBack = BaseClr
  102.     CASE 2 ' Recessed
  103.       BoxDef$ = "╔═╕│┘─╙║ "
  104.       TLFore = ContClr: BRFore = HiClr
  105.       TLBack = BaseClr: BRBack = BaseClr
  106.     CASE 3 ' Raised Panel
  107.       BoxDef$ = "█▀▄██▄▀█ "
  108.       TLFore = HiClr: BRFore = ShadClr
  109.       TLBack = BaseClr: BRBack = BaseClr
  110.     CASE 4 ' Recessed Panel
  111.       BoxDef$ = "█▀▄██▄▀█ "
  112.       TLFore = ShadClr: BRFore = HiClr
  113.       TLBack = BaseClr: BRBack = BaseClr
  114.     CASE ELSE ' Flat
  115.       BoxDef$ = ""
  116.       TLFore = ContClr: BRFore = ContClr
  117.       TLBack = BaseClr: BRBack = BaseClr
  118.    END SELECT
  119.    DrawBox t, l, b, r, TLFore, TLBack, BRFore, BRBack, BoxDef$
  120. END SUB
  121.  
  122. SUB DrawBox (t, l, b, r, TLFore, TLBack, BRFore, BRBack, BoxDef$)
  123.   ' default box characters
  124.   IF LEN(BoxDef$) = 0 THEN Box$ = "┌─┐│┘─└│ " ELSE Box$ = BoxDef$
  125.  
  126.   ' top and left
  127.   COLOR TLFore, TLBack
  128.   LOCATE t, l: PRINT LEFT$(Box$, 1);
  129.   FOR i = l + 1 TO r - 1
  130.     LOCATE t, i: PRINT MID$(Box$, 2, 1);
  131.   NEXT
  132.   FOR i = t + 1 TO b - 1
  133.     LOCATE i, l: PRINT MID$(Box$, 8, 1);
  134.   NEXT
  135.   LOCATE b, l: PRINT MID$(Box$, 7, 1);
  136.  
  137.   ' bottom and right
  138.   COLOR BRFore, BRBack
  139.   LOCATE t, r: PRINT MID$(Box$, 3, 1);
  140.   FOR i = t + 1 TO b - 1
  141.     LOCATE i, r: PRINT MID$(Box$, 4, 1);
  142.   NEXT
  143.   LOCATE b, r: PRINT MID$(Box$, 5, 1);
  144.   FOR i = l + 1 TO r - 1
  145.     LOCATE b, i: PRINT MID$(Box$, 6, 1);
  146.   NEXT
  147.   
  148.   ' fill
  149.   Fill t + 1, l + 1, b - 1, r - 1, TLFore, TLBack, MID$(Box$, 9, 1)
  150.  
  151. END SUB
  152.  
  153. SUB Fill (t, l, b, r, Fore, Back, Char$)
  154.   COLOR Fore, Back
  155.   FOR i = t TO b
  156.     LOCATE i, l: PRINT STRING$(r - l + 1, Char$);
  157.   NEXT
  158. END SUB
  159.  
  160. SUB Strip3D (t, l, b, r, StripType)
  161.   SELECT CASE StripType
  162.     CASE 1 ' raised
  163.       LFore = HiClr: RFore = ShadClr: MFore = BaseClr: Back = BaseClr
  164.     CASE 2 ' recessed
  165.       LFore = ShadClr: RFore = HiClr: MFore = BaseClr: Back = BaseClr
  166.     CASE 3 ' raised black
  167.       LFore = HiClr: RFore = ShadClr: MFore = ContClr: Back = ContClr
  168.     CASE 4 ' recessed black
  169.       LFore = ShadClr: RFore = HiClr: MFore = ContClr: Back = ContClr
  170.   END SELECT
  171.   wide = r - l - 1
  172.   IF wide < 1 THEN wide = 1
  173.   FOR i = t TO b
  174.     LOCATE i, l
  175.     COLOR LFore, Back: PRINT "▌";
  176.     COLOR MFore, BaseClr: PRINT STRING$(wide, "█");
  177.     COLOR RFore, Back: PRINT "▐";
  178.   NEXT
  179. END SUB
  180.  
  181.